home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / gnu / emacs.lha / emacs-19.16 / lisp / rmailkwd.el < prev    next >
Lisp/Scheme  |  1992-09-21  |  10KB  |  272 lines
  1. ;;; rmailkwd.el --- part of the "RMAIL" mail reader for Emacs.
  2.  
  3. ;; Copyright (C) 1985, 1988 Free Software Foundation, Inc.
  4.  
  5. ;; Maintainer: FSF
  6. ;; Keywords: mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24. ;;; Code:
  25.  
  26. ;; Global to all RMAIL buffers.  It exists primarily for the sake of
  27. ;; completion.  It is better to use strings with the label functions
  28. ;; and let them worry about making the label.
  29.  
  30. (defvar rmail-label-obarray (make-vector 47 0))
  31.  
  32. ;; Named list of symbols representing valid message attributes in RMAIL.
  33.  
  34. (defconst rmail-attributes
  35.   (cons 'rmail-keywords
  36.     (mapcar '(lambda (s) (intern s rmail-label-obarray))
  37.         '("deleted" "answered" "filed" "forwarded" "unseen" "edited"))))
  38.  
  39. (defconst rmail-deleted-label (intern "deleted" rmail-label-obarray))
  40.  
  41. ;; Named list of symbols representing valid message keywords in RMAIL.
  42.  
  43. (defvar rmail-keywords nil)
  44.  
  45. (defun rmail-add-label (string)
  46.   "Add LABEL to labels associated with current RMAIL message.
  47. Completion is performed over known labels when reading."
  48.   (interactive (list (rmail-read-label "Add label")))
  49.   (rmail-set-label string t))
  50.  
  51. (defun rmail-kill-label (string)
  52.   "Remove LABEL from labels associated with current RMAIL message.
  53. Completion is performed over known labels when reading."
  54.   (interactive (list (rmail-read-label "Remove label")))
  55.   (rmail-set-label string nil))
  56.  
  57. (defun rmail-read-label (prompt)
  58.   (if (not rmail-keywords) (rmail-parse-file-keywords))
  59.   (let ((result
  60.      (completing-read (concat prompt
  61.                   (if rmail-last-label
  62.                       (concat " (default "
  63.                           (symbol-name rmail-last-label)
  64.                           "): ")
  65.                     ": "))
  66.               rmail-label-obarray
  67.               nil
  68.               nil)))
  69.     (if (string= result "")
  70.     rmail-last-label
  71.       (setq rmail-last-label (rmail-make-label result t)))))
  72.  
  73. (defun rmail-set-label (l state &optional n)
  74.   (rmail-maybe-set-message-counters)
  75.   (if (not n) (setq n rmail-current-message))
  76.   (aset rmail-summary-vector (1- n) nil)
  77.   (let* ((attribute (rmail-attribute-p l))
  78.      (keyword (and (not attribute)
  79.                (or (rmail-keyword-p l)
  80.                (rmail-install-keyword l))))
  81.      (label (or attribute keyword)))
  82.     (if label
  83.     (let ((omax (- (buffer-size) (point-max)))
  84.           (omin (- (buffer-size) (point-min)))
  85.           (buffer-read-only nil)
  86.           (case-fold-search t))
  87.       (unwind-protect
  88.           (save-excursion
  89.         (widen)
  90.         (goto-char (rmail-msgbeg n))
  91.         (forward-line 1)
  92.         (if (not (looking-at "[01],"))
  93.             nil
  94.           (let ((start (1+ (point)))
  95.             (bound))
  96.             (narrow-to-region (point) (progn (end-of-line) (point)))
  97.             (setq bound (point-max))
  98.             (search-backward ",," nil t)
  99.             (if attribute
  100.             (setq bound (1+ (point)))
  101.               (setq start (1+ (point))))
  102.             (goto-char start)
  103. ;            (while (re-search-forward "[ \t]*,[ \t]*" nil t)
  104. ;              (replace-match ","))
  105. ;            (goto-char start)
  106.             (if (re-search-forward
  107.                (concat ", " (rmail-quote-label-name label) ",")
  108.                bound
  109.                'move)
  110.             (if (not state) (replace-match ","))
  111.               (if state (insert " " (symbol-name label) ",")))
  112.             (if (eq label rmail-deleted-label)
  113.             (rmail-set-message-deleted-p n state)))))
  114.         (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax))
  115.         (if (= n rmail-current-message) (rmail-display-labels)))))))
  116.  
  117. ;; Commented functions aren't used by RMAIL but might be nice for user
  118. ;; packages that do stuff with RMAIL.  Note that rmail-message-labels-p
  119. ;; is in rmail.el now.
  120.  
  121. ;(defun rmail-message-attribute-p (attribute &optional n)
  122. ;  "Returns t if ATTRIBUTE on NTH or current message."
  123. ;  (rmail-message-labels-p (rmail-make-label attribute t) n))
  124.  
  125. ;(defun rmail-message-keyword-p (keyword &optional n)
  126. ;  "Returns t if KEYWORD on NTH or current message."
  127. ;  (rmail-message-labels-p (rmail-make-label keyword t) n t))
  128.  
  129. ;(defun rmail-message-label-p (label &optional n)
  130. ;  "Returns symbol if LABEL (attribute or keyword) on NTH or current message."
  131. ;  (rmail-message-labels-p (rmail-make-label label t) n 'all))
  132.  
  133. ;; Not used by RMAIL but might be nice for user package.
  134.  
  135. ;(defun rmail-parse-message-labels (&optional n)
  136. ;  "Returns labels associated with NTH or current RMAIL message.
  137. ;Results is a list of two lists.  The first is the message attributes
  138. ;and the second is the message keywords.  Labels are represented as symbols."
  139. ;  (let ((omin (- (buffer-size) (point-min)))
  140. ;    (omax (- (buffer-size) (point-max)))
  141. ;    (result))    
  142. ;    (unwind-protect
  143. ;    (save-excursion
  144. ;      (let ((beg (rmail-msgbeg (or n rmail-current-message))))
  145. ;        (widen)
  146. ;        (goto-char beg)
  147. ;        (forward-line 1)
  148. ;        (if (looking-at "[01],")
  149. ;        (save-restriction
  150. ;          (narrow-to-region (point) (save-excursion (end-of-line) (point)))
  151. ;          (rmail-nuke-whitespace)
  152. ;          (goto-char (1+ (point-min)))
  153. ;          (list (mail-parse-comma-list) (mail-parse-comma-list))))))
  154. ;      (narrow-to-region (- (buffer-size) omin)
  155. ;                 (- (buffer-size) omax))
  156. ;      nil)))
  157.  
  158. (defun rmail-attribute-p (s)
  159.   (let ((symbol (rmail-make-label s)))
  160.     (if (memq symbol (cdr rmail-attributes)) symbol)))
  161.  
  162. (defun rmail-keyword-p (s)
  163.   (let ((symbol (rmail-make-label s)))
  164.     (if (memq symbol (cdr (rmail-keywords))) symbol)))
  165.  
  166. (defun rmail-make-label (s &optional forcep)
  167.   (cond ((symbolp s) s)
  168.     (forcep (intern (downcase s) rmail-label-obarray))
  169.     (t  (intern-soft (downcase s) rmail-label-obarray))))
  170.  
  171. (defun rmail-force-make-label (s)
  172.   (intern (downcase s) rmail-label-obarray))
  173.  
  174. (defun rmail-quote-label-name (label)
  175.   (regexp-quote (symbol-name (rmail-make-label label t))))
  176.  
  177. ;; Motion on messages with keywords.
  178.  
  179. (defun rmail-previous-labeled-message (n labels)
  180.   "Show previous message with one of the labels LABELS.
  181. LABELS should be a comma-separated list of label names.
  182. If LABELS is empty, the last set of labels specified is used.
  183. With prefix argument N moves backward N messages with these labels."
  184.   (interactive "p\nsMove to previous msg with labels: ")
  185.   (rmail-next-labeled-message (- n) labels))
  186.  
  187. (defun rmail-next-labeled-message (n labels)
  188.   "Show next message with one of the labels LABELS.
  189. LABELS should be a comma-separated list of label names.
  190. If LABELS is empty, the last set of labels specified is used.
  191. With prefix argument N moves forward N messages with these labels."
  192.   (interactive "p\nsMove to next msg with labels: ")
  193.   (if (string= labels "")
  194.       (setq labels rmail-last-multi-labels))
  195.   (or labels
  196.       (error "No labels to find have been specified previously"))
  197.   (setq rmail-last-multi-labels labels)
  198.   (rmail-maybe-set-message-counters)
  199.   (let ((lastwin rmail-current-message)
  200.     (current rmail-current-message)
  201.     (regexp (concat ", ?\\("
  202.             (mail-comma-list-regexp labels)
  203.             "\\),")))
  204.     (save-restriction
  205.       (widen)
  206.       (while (and (> n 0) (< current rmail-total-messages))
  207.     (setq current (1+ current))
  208.     (if (rmail-message-labels-p current regexp)
  209.         (setq lastwin current n (1- n))))
  210.       (while (and (< n 0) (> current 1))
  211.     (setq current (1- current))
  212.     (if (rmail-message-labels-p current regexp)
  213.         (setq lastwin current n (1+ n)))))
  214.     (rmail-show-message lastwin)
  215.     (if (< n 0)
  216.     (message "No previous message with labels %s" labels))
  217.     (if (> n 0)
  218.     (message "No following message with labels %s" labels))))
  219.  
  220. ;;; Manipulate the file's Labels option.
  221.  
  222. ;; Return a list of symbols for all
  223. ;; the keywords (labels) recorded in this file's Labels option.
  224. (defun rmail-keywords ()
  225.   (or rmail-keywords (rmail-parse-file-keywords)))
  226.  
  227. ;; Set rmail-keywords to a list of symbols for all
  228. ;; the keywords (labels) recorded in this file's Labels option.
  229. (defun rmail-parse-file-keywords ()
  230.   (save-restriction
  231.     (save-excursion
  232.       (widen)
  233.       (goto-char 1)
  234.       (setq rmail-keywords
  235.         (if (search-forward "\nLabels:" (rmail-msgbeg 1) t)
  236.         (progn
  237.           (narrow-to-region (point) (progn (end-of-line) (point)))
  238.           (goto-char (point-min))
  239.           (cons 'rmail-keywords
  240.             (mapcar 'rmail-force-make-label
  241.                 (mail-parse-comma-list)))))))))
  242.  
  243. ;; Add WORD to the list in the file's Labels option.
  244. ;; Any keyword used for the first time needs this done.
  245. (defun rmail-install-keyword (word)
  246.   (let ((keyword (rmail-make-label word t))
  247.     (keywords (rmail-keywords)))
  248.     (if (not (or (rmail-attribute-p keyword)
  249.          (rmail-keyword-p keyword)))
  250.     (let ((omin (- (buffer-size) (point-min)))
  251.           (omax (- (buffer-size) (point-max))))
  252.       (unwind-protect
  253.           (save-excursion
  254.         (widen)
  255.         (goto-char 1)
  256.         (let ((case-fold-search t)
  257.               (buffer-read-only nil))
  258.           (or (search-forward "\nLabels:" nil t)
  259.               (progn
  260.             (end-of-line)
  261.             (insert "\nLabels:")))
  262.           (delete-region (point) (progn (end-of-line) (point)))
  263.           (setcdr keywords (cons keyword (cdr keywords)))
  264.           (while (setq keywords (cdr keywords))
  265.             (insert (symbol-name (car keywords)) ","))
  266.           (delete-char -1)))
  267.         (narrow-to-region (- (buffer-size) omin)
  268.                   (- (buffer-size) omax)))))
  269.     keyword))
  270.  
  271. ;;; rmailkwd.el ends here
  272.